PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/win/pascal/stoplit.exe/STOPLITE.PAS

Pascal/Delphi Source File | 1992-06-18 | 5.7 KB | 205 lines

program StopLight;

{
  Program:            STOPLITE.PAS
  Version:            1.0
  Creation Date:      June 18, 1992
  Modification Date:  June 18, 1992
  Operating System:   MS-DOS 3.x and Windows 3.x
  Hardware Required:  Windows-capable computer system
  Programming System: Turbo Pascal for Windows 1.0
  Author:             Craig Boyd
  Ownership:          Released to the public domain


  About This Program

  Demonstration program showing how to use the wm_timer message
  to animate an icon.


  Update History

  update    ver   description (author)
  -------   ---   -----------
  9206.18   1.0   Released to public domain. (CSB)

}

uses
  Strings,
  WinTypes,
  WinProcs,
  WObjects,
  Win31;               { <-- omit if you are using TPW under Windows 3.0 }

{$R STOPLITE.RES}

{-- Global Declarations -------------------------------------------------}

const
  AppName    : pchar = 'Stoplight';
  AppTitle   : pchar = 'Stoplight';
  GreenLite  = 200;                                    { icon id numbers }
  YellowLite = 201;
  RedLite    = 202;

type
  TStoplightApp = object(TApplication)
    procedure InitMainWindow; virtual;
  end;

  PMyWindow = ^TStoplightWindow;
  TStoplightWindow = object(TWindow)
    Counter : byte;              { counts passes thru the WMTimer method }
    Red,                                                  { icon handles }
    Yellow,
    Green   : hicon;
    destructor Done; virtual;
    procedure SetupWindow; virtual;
    function GetClassName : pchar; virtual;
    procedure GetWindowClass(var WndClass : tWndClass); virtual;
    procedure WMQueryOpen(var Msg : TMessage);
      virtual wm_First + wm_QueryOpen;
    procedure WMTimer(var Msg : TMessage);
      virtual wm_First + wm_Timer;
  end;

{-- TStoplightWindow Methods --------------------------------------------}

destructor TStoplightWindow.Done;
  begin
    {
      Always kill the timer when you're done with it.
    }
    KillTimer(HWindow,1);
    TWindow.Done;
  end { TStoplightWindow.Done };

procedure TStoplightWindow.SetupWindow;
  var
    SysMenu : hMenu;
  begin
    TWindow.SetupWindow;
    {
      Remove unwanted system menu options.  Note: It seems that
      removing the sc_Restore menu option is enough to prevent
      an icon from being opened; the override of wm_QueryOpen
      may be redundant.
    }
    SysMenu := GetSystemMenu(hWindow,false);
    DeleteMenu(SysMenu,sc_Restore,mf_ByCommand);
    DeleteMenu(SysMenu,sc_Size,mf_ByCommand);
    DeleteMenu(SysMenu,sc_Minimize,mf_ByCommand);
    DeleteMenu(SysMenu,sc_Maximize,mf_ByCommand);
    {
      Reset our timer pass counter.
    }
    Counter := 0;
    {
      Start a two-second timer.
      Complain and exit if none are available.
    }
    if SetTimer(HWindow,1,2000,nil) = 0 then begin
      MessageBeep(0);
      MessageBox(HWindow,'No free timers','Error',mb_OK or mb_IconExclamation);
      halt(1);
    end;
 end { TStoplightWindow.SetupWindow };

function TStoplightWindow.GetClassName;
  begin
    GetClassName := AppName;
  end { TStoplightWindow.GetClassName };

procedure TStoplightWindow.GetWindowClass;
  begin
    TWindow.GetWindowClass(WndClass);
    {
      Load the three traffic light icon resources.
    }
    Red := LoadIcon(HInstance,pchar(RedLite));
    Yellow := LoadIcon(HInstance,pchar(YellowLite));
    Green := LoadIcon(HInstance,pchar(GreenLite));
    {
      We'll start with the green light.
    }
    WndClass.hIcon := Green;
  end { TStoplightWindow.GetWindowClass };

procedure TStoplightWindow.WMQueryOpen;
{
  Override requests to open the window.
}
  begin
    Msg.Result := 0;
  end { TStoplightWindow.WMQueryOpen };

procedure TStoplightWindow.WMTimer;
{
  Here's where all the work is done.  This method handles the timer
  messages, which are sent at two-second intervals.  We want the visible
  icon to cycle from green to yellow to red, then start all over again.
  We use a counter to determine which icon to display.  When this method
  is called, it checks the value of the counter and responds as shown
  in the following table...

  Value  Response
  -----  --------
    0    Load and display green light icon.
    1    Do nothing.
    2    Load and display yellow light icon.
    3    Load and display red light icon.
    4    Do nothing.
    5    Reset the counter.

  In other words, we display the green light for 4 seconds, the yellow
  light for 2 seconds, the red light for four seconds, then start all
  over again.

  By adjusting the timer frequency (in TStoplightWindow.SetupWindow) and
  the counter step values, you can simulate the traffic light cycle of
  your favorite intersection!
}
  begin
    inc(Counter);
    if Counter > 4 then Counter := 0;
    {
      Update TStoplightWindow's icon handle, based on the counter value.
    }
    case Counter of
      0 : SetClassWord(HWindow,gcw_HIcon,Green);
      2 : SetClassWord(HWindow,gcw_HIcon,Yellow);
      3 : SetClassWord(HWindow,gcw_HIcon,Red);
    else
      exit;
    end;
    {
      Force the new icon to be displayed.
    }
    InvalidateRect(HWindow,nil,true);
  end { TStoplightWindow.WMTimer };

{-- TStoplightApp Methods -----------------------------------------------}

procedure TStoplightApp.InitMainWindow;
  begin
    MainWindow := New(PMyWindow,Init(nil,AppTitle));
  end { TStoplightApp.InitMainWindow };

{-- Main Program --------------------------------------------------------}

var
  StoplightApp : TStoplightApp;

begin
  {
    We want our app to start out minimized.
  }
  CmdShow := sw_ShowMinimized;

  StoplightApp.Init(AppName);
  StoplightApp.Run;
  StoplightApp.Done;
end.